home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / bufmac.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  8KB  |  208 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;; This file contains macro definitions for the BUFFER object for Common-Lisp
  4. ;;; X windows version 11
  5.  
  6. ;;;
  7. ;;;             TEXAS INSTRUMENTS INCORPORATED
  8. ;;;                  P.O. BOX 2909
  9. ;;;                   AUSTIN, TEXAS 78769
  10. ;;;
  11. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  12. ;;;
  13. ;;; Permission is granted to any individual or institution to use, copy, modify,
  14. ;;; and distribute this software, provided that this complete copyright and
  15. ;;; permission notice is maintained, intact, in all copies and supporting
  16. ;;; documentation.
  17. ;;;
  18. ;;; Texas Instruments Incorporated provides this software "as is" without
  19. ;;; express or implied warranty.
  20. ;;;
  21.  
  22. (in-package 'xlib :use '(lisp))
  23.  
  24. ;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them.
  25.  
  26. (defmacro write-card8 (byte-index item)
  27.   `(setf (aref-card8 buffer-bbuf (index+ buffer-boffset ,byte-index))
  28.      (the card8 ,item)))
  29.  
  30. (defmacro write-int8 (byte-index item)
  31.   `(setf (aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index))
  32.      (the int8 ,item)))
  33.  
  34. (defmacro write-card16 (byte-index item)
  35.   #+clx-overlapping-arrays
  36.   `(setf (aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
  37.      (the card16 ,item))
  38.   #-clx-overlapping-arrays
  39.   `(setf (aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index))
  40.      (the card16 ,item)))
  41.  
  42. (defmacro write-int16 (byte-index item)
  43.   #+clx-overlapping-arrays
  44.   `(setf (aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
  45.      (the int16 ,item))
  46.   #-clx-overlapping-arrays
  47.   `(setf (aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index))
  48.      (the int16 ,item)))
  49.  
  50. (defmacro write-card32 (byte-index item)
  51.   #+clx-overlapping-arrays
  52.   `(setf (aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
  53.      (the card32 ,item))
  54.   #-clx-overlapping-arrays
  55.   `(setf (aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index))
  56.      (the card32 ,item)))
  57.  
  58. (defmacro write-int32 (byte-index item)
  59.   #+clx-overlapping-arrays
  60.   `(setf (aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
  61.      (the int32 ,item))
  62.   #-clx-overlapping-arrays
  63.   `(setf (aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index))
  64.      (the int32 ,item)))
  65.  
  66. (defmacro write-card29 (byte-index item)
  67.   #+clx-overlapping-arrays
  68.   `(setf (aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
  69.      (the card29 ,item))
  70.   #-clx-overlapping-arrays
  71.   `(setf (aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index))
  72.      (the card29 ,item)))
  73.  
  74. (defmacro set-buffer-offset (value &key (sizes '(8 16 32)))
  75.   (unless (listp sizes) (setq sizes (list sizes)))
  76.   `(progn
  77.      (setq buffer-boffset ,value)
  78.      #+clx-overlapping-arrays
  79.      ,@(when (member 16 sizes)
  80.      `((setq buffer-woffset (the array-index (index-ash buffer-boffset -1)))))
  81.      #+clx-overlapping-arrays
  82.      ,@(when (member 32 sizes)
  83.      `((setq buffer-loffset (the array-index (index-ash buffer-boffset -2)))))))
  84.  
  85. (defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body)
  86.   (unless (listp sizes) (setq sizes (list sizes)))
  87.   `(let ()
  88.      (declare-bufmac)
  89.      ,(if length
  90.       (unless (eq length :none)
  91.         `(when (index>= (index+ (buffer-boffset ,buffer) ,length) (buffer-limit ,buffer))
  92.            (buffer-flush ,buffer)))
  93.     `(when (index>= (buffer-boffset ,buffer) (buffer-limit ,buffer))
  94.        (buffer-flush ,buffer)))
  95.      (let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset ,buffer))))
  96.         ,@(when (or #-clx-overlapping-arrays t (member 8 sizes))
  97.         `((buffer-bbuf (buffer-obuf8 ,buffer))))
  98.         #+clx-overlapping-arrays
  99.         ,@(when (member 16 sizes)
  100.         `((buffer-woffset (index-ash buffer-boffset -1))
  101.           (buffer-wbuf (buffer-obuf16 ,buffer))))
  102.         #+clx-overlapping-arrays
  103.         ,@(when (member 32 sizes)
  104.         `((buffer-loffset (index-ash buffer-boffset -2))
  105.           (buffer-lbuf (buffer-obuf32 ,buffer)))))
  106.        (declare (type array-index buffer-boffset))
  107.        ,@(when (or #-clx-overlapping-arrays t (member 8 sizes))
  108.        '((declare-array buffer-bytes buffer-bbuf)))
  109.        #+clx-overlapping-arrays
  110.        ,@(when (member 16 sizes)
  111.        `((declare (type array-index buffer-woffset))
  112.          (declare-array buffer-words buffer-wbuf)))
  113.        #+clx-overlapping-arrays
  114.        ,@(when (member 32 sizes)
  115.        `((declare (type array-index buffer-loffset))
  116.          (declare-array buffer-longs buffer-lbuf)))
  117.        buffer-boffset
  118.        ,@(when (or #-clx-overlapping-arrays t (member 8 sizes)) '(buffer-bbuf))
  119.        #+clx-overlapping-arrays
  120.        ,@(when (member 16 sizes) '(buffer-woffset buffer-wbuf))
  121.        #+clx-overlapping-arrays
  122.        ,@(when (member 32 sizes) '(buffer-loffset buffer-lbuf))
  123.        ,@body
  124.        )))
  125.  
  126. (defmacro writing-buffer-send ((buffer &rest options) &body body)
  127.   ;; BODY may contain calls to (WRITE32 item) (WRITE16 item) or (WRITE8 item)
  128.   ;; These calls will place "item" in the next available word, half-word
  129.   ;; or byte in BUFFER.  BUFFER will be flushed when full.
  130.   (declare-arglist (buffer &key sizes index length) &body body)
  131.   `(compiler-let ((*buffer* ',buffer))
  132.      (with-buffer-output (,buffer ,@options) ,@body)))
  133.  
  134. (defmacro reading-buffer-reply ((buffer &rest options) &body body)
  135.   (declare-arglist (buffer &key sizes) &body body)
  136.   ;; BODY may contain calls to (READ32 &optional index) etc.
  137.   ;; These calls will read from the input buffer at byte
  138.   ;; offset INDEX.  If INDEX is not supplied, then the next
  139.   ;; word, half-word or byte is returned.
  140.   (let ((reply-buffer (gensym)))
  141.     `(let ((,reply-buffer (buffer-reply-buffer ,buffer)))
  142.        (compiler-let ((*buffer* ',buffer))
  143.      (with-buffer-input (,reply-buffer ,@options) ,@body)))))
  144.  
  145. ;;; These next two macros are just used internally in buffer
  146.  
  147. (defmacro reading-buffer-chunks (type &body body)
  148.   (when (> (length body) 2)
  149.     (error "reading-buffer-chunks called with too many forms"))
  150.   (let* ((size (* 8 (index-increment type)))
  151.      (form #-clx-overlapping-arrays
  152.            (first body)
  153.            #+clx-overlapping-arrays        ; XXX type dependencies
  154.            (or (second body)
  155.            (first body))))
  156.     `(reading-buffer-reply (buffer :sizes ,(reverse (adjoin size '(8))))
  157.        (do* ((i start end)
  158.          (i-end (index+ start nitems))
  159.          (size (index-ash (reply-size (buffer-reply-buffer buffer))
  160.                   ,(- (truncate size 16))))
  161.          (len nitems (index- len chunk))
  162.          (chunk (index-min size len) (index-min size len))
  163.          (end (index+ i chunk) (index+ i chunk)))
  164.         ((index>= i i-end) data)
  165.      (declare (type array-index i-end size len chunk end i))
  166.      (buffer-input buffer buffer-bbuf 0
  167.                (lround ,(if (= size 8)
  168.                     'chunk
  169.                     `(index-ash chunk ,(truncate size 16)))))
  170.      ,form))))
  171.  
  172. (defmacro writing-buffer-chunks (type args decls &body body)
  173.   (when (> (length body) 2)
  174.     (error "writing-buffer-chunks called with too many forms"))
  175.   (let* ((size (* 8 (index-increment type)))
  176.      (form #-clx-overlapping-arrays
  177.            (first body)
  178.            #+clx-overlapping-arrays        ; XXX type dependencies
  179.            (or (second body)
  180.            (first body))))
  181.     `(writing-buffer-send (buffer :index boffset :sizes ,(reverse (adjoin size '(8))))
  182.        ;; Loop filling the buffer
  183.        (do* (,@args
  184.          ;; Number of bytes needed to output
  185.          (len ,(if (= size 8)
  186.                `(index- end start)
  187.                `(index-ash (index- end start) ,(truncate size 16)))
  188.           (index- len chunk))
  189.          ;; Number of bytes available in buffer
  190.          (chunk (index-min len (index- (buffer-size buffer) buffer-boffset))
  191.             (index-min len (index- (buffer-size buffer) buffer-boffset))))
  192.         ((not (index-plusp len)))
  193.      (declare ,@decls
  194.           (type array-index len chunk))
  195.      ,form
  196.      (index-incf buffer-boffset chunk)
  197.      ;; Flush the buffer
  198.      (when (and (index-plusp len)
  199.             (index> buffer-boffset (buffer-limit buffer)))
  200.        (setf (buffer-boffset buffer) buffer-boffset)
  201.        (buffer-flush buffer)
  202.        (setq buffer-boffset (buffer-boffset buffer))
  203.        #+clx-overlapping-arrays
  204.        ,(case size
  205.           (16 '(setq buffer-woffset (index-ash buffer-boffset -1)))
  206.           (32 '(setq buffer-loffset (index-ash buffer-boffset -2))))))
  207.        (setf (buffer-boffset buffer) (lround buffer-boffset)))))
  208.